home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr53
/
122_01.zip
/
PBASE2
< prev
next >
Wrap
Text File
|
1993-06-02
|
23KB
|
1,099 lines
% *********************************************************
% * *
% * PISTOL-Portably Implemented Stack Oriented Language *
% * Version 2.0 *
% * (C) 1983 by Ernest E. Bergmann *
% * Physics, Building #16 *
% * Lehigh Univerisity *
% * Bethlehem, Pa. 18015 *
% * *
% * Permission is hereby granted for all reproduction and *
% * distribution of this material provided this notice is *
% * included. *
% * *
% *********************************************************
% BASIC DEFINITIONS FOR PISTOL 2.0
%
% DECIMAL mode initially
%
+5 W * USER + W@ W@ % used for 'LAST-PRIMITIVE
'W* W 1 - IF : W * ;
ELSE $: ;$
THEN
'USER+ USER IF $: USER + ;$
ELSE $: ;$
THEN
'TRANS $: W* USER+ ;$ % TRANSLATES LOGICAL ADDRESSES TO ACTUAL RAM ADDR.
% TRANS MUST USE "$:" FOR THE 'DIS PACKAGE
'TRANS@ : TRANS W@ ;
'ARGPATCH : +5 TRANS@ W@ W + W! ; % for 'CONSTANT 'VARIABLE, 'ARRAY
'CONSTANT : : 0 ; ARGPATCH ;
'LAST-PRIMITIVE CONSTANT
-1 'TRUE CONSTANT
0 'FALSE CONSTANT
-21 TRANS@ 'MININT CONSTANT
-20 TRANS@ 'MAXLINNO CONSTANT
-19 TRANS@ 'CHKLMT CONSTANT
-18 TRANS@ 'RAMMIN CONSTANT
-17 TRANS@ 'STRINGSMIN CONSTANT
-16 TRANS@ 'STRINGSMAX CONSTANT
-15 TRANS@ 'VBASE CONSTANT
-14 TRANS@ 'VSIZE CONSTANT
VBASE VSIZE W* + 'VMAX CONSTANT
-13 TRANS@ 'CSIZE CONSTANT
-12 TRANS@ 'LSIZE CONSTANT
-11 TRANS@ 'RSIZE CONSTANT
-10 TRANS@ 'SSIZE CONSTANT
-9 TRANS@ 'LINEBUF CONSTANT
LINEBUF 200 + 'EDITBUF CONSTANT
-8 TRANS@ 'COMPBUF CONSTANT
-7 TRANS@ 'RAMMAX CONSTANT
-6 TRANS@ 'MAXORD CONSTANT
-5 TRANS@ 'MAXINT CONSTANT
-4 TRANS@ 'VERSION CONSTANT
-3 TRANS@ 'NEWLINE CONSTANT
-2 TRANS@ 'READ_PROTECT CONSTANT
-1 TRANS@ 'WRITE_PROTECT CONSTANT
'ON : TRUE SWAP W! ;
'OFF : FALSE SWAP W! ;
'INFILE : +7 TRANS@ ;
'BYE : +31 TRANS ON ;
+34 TRANS 'ABORT-PATCH CONSTANT
+33 TRANS 'CONVERT-PATCH CONSTANT
+32 TRANS 'PROMPT-PATCH CONSTANT
+29 TRANS '(PISTOL<) CONSTANT
+28 TRANS '.V CONSTANT
+24 TRANS '#GET-ADDR CONSTANT % FOR PATCHING #GETLINE
+23 TRANS 'TAB-SIZE CONSTANT
+22 TRANS 'TRACE-ADDR CONSTANT
+21 TRANS 'ENDCASE-PATCH CONSTANT
+20 TRANS 'COLUMN CONSTANT
+19 TRANS 'TERMINAL-WIDTH CONSTANT
+18 TRANS '#LINES CONSTANT
+17 TRANS 'TERMINAL-PAGE CONSTANT
+16 TRANS 'COMPILE-END-PATCH CONSTANT
+15 TRANS 'TRACE-LEVEL CONSTANT % USED AS BOOLEAN
% AND LEVEL INDICATOR
+13 TRANS 'RAISE CONSTANT
+11 TRANS 'NEXTCH^ CONSTANT
+10 TRANS 'CONSOLE CONSTANT
+9 TRANS 'ECHO CONSTANT
+8 TRANS 'LIST CONSTANT
+6 TRANS 'PREVIOUS CONSTANT % UPDATED BY (V)FIND
+5 TRANS 'CURRENT CONSTANT
+4 TRANS 'OLD-EOSTRINGS CONSTANT % END OF PERMANENT
% STRINGS VARIABLE
+3 TRANS 'CURRENT-EOSTRINGS CONSTANT
+2 TRANS '.D CONSTANT
+1 TRANS '.C CONSTANT
+0 TRANS 'RADIX CONSTANT
STRINGSMIN 'RADIX-INDICATOR CONSTANT
STRINGSMIN 1 + 'SYNTAXBASE CONSTANT
'NOP : ;
'DUP : 0 S@ ;
'1+ : 1 + ;
'1- : 1 - ;
'W+ : W + ;
'W- : W - ;
'W<- : SWAP W! ;
'1+W! : DUP W@ 1+ W<- ;
'W+W! : DUP W@ W+ W<- ;
'CR : NEWLINE TYO ;
'SPACE : 32 TYO ;
'SPACES : 0 DO SPACE LOOP ;
'DDUP : 1 S@ 1 S@ ;
'OVER : 1 S@ ;
'2OVER : 2 S@ ;
'3OVER : 3 S@ ; % USED BY DIS PACKAGE(DON'T CHANGE!)
'UNDER : SWAP DROP ;
'TYPE : 0 DO DUP C@ TYO 1+ LOOP DROP ;
'LT : MININT SWAP 1- .. ;
'GT : 1+ MAXINT .. ;
'LINE-SPACE? : COLUMN W@ + TERMINAL-WIDTH W@ LT
IF ELSE CR THEN ;
'MSG : DUP C@ LINE-SPACE?
DUP 1+ SWAP C@ TYPE ;
'IFCR : COLUMN W@ 0 GT IF CR THEN ;
'ERR : IFCR ABORT ;
'MERR : CONSOLE ON MSG ERR ;
'INDENT : DUP TERMINAL-WIDTH W@ LT IF
COLUMN W@ - SPACES
ELSE IFCR DROP
THEN ;
'TAB : 9 TYO ;
'TABS : 0 DO TAB LOOP ;
'ALLOT : W* .D W@ + .D W! ; % advances dictionary pointer
% by the amount given by top of stack
'W, : % PLACES TOS AT END OF DICTIONARY
.D W@ W! 1 ALLOT
;
'VARIABLE : : 3 ; % create definition
.D W@ ARGPATCH % point it at end of dictionary
W, % initialize variable
; % finish with allocating space
'ARRAY : : 3 ; % create definition
.D W@ ARGPATCH % point it at end of dictionary
ALLOT ; % allocate requested space and ;
% VOCABULARY RELATED DEFINITIONS:
'> : .V W@ DUP VBASE GT % "POPS" VOCABULARY STACK
IF W- .V W!
ELSE "*** VSTACK UNDERFLOW***" MERR
THEN
;
'<V : % TRANSFERS TOS TO TOP OF VSTACK
.V W@ DUP VMAX LT
IF W+ DUP .V W! W!
ELSE "*** VSTACK OVERFLOW***" MERR
THEN
;
'PISTOL< : (PISTOL<) <V ;
(PISTOL<) 'BRANCH-LIST VARIABLE
'BRANCH : % CREATES AN ARRAY OF TWO ELEMENTS
% AND A PROCEDURE THAT PUSHES A ^
% TO THE FIRST ELEMENT OF THE ARRAY
% THIS FIRST ELEMENT CONTAINS A ^
% TO THE CURRENT HEAD OF THE VOCABULARY
% BRANCH AND THE SECOND ELEMENT IS A
% BACKWARD LINK TO THE PREVIOUS HEAD.
% BRANCH-LIST CONTAINS THE ^ TO THE
% THREADED LIST OF BRANCHES THAT HAVE
% BEEN DEFINED; THE BACKWARD LINK FOR
% (PISTOL<) IS "NIL"
: 3 <V ; .D W@ ARGPATCH
0 .D W@ W!
BRANCH-LIST W@ .D W@ W+
W!
.D W@ BRANCH-LIST
W!
2 ALLOT
;
'UNLINKED< BRANCH % CAN BE USED FOR RARELY USED, OBSCURE,
% OR DANGEROUS WORDS
CURRENT W@ W@ W+ W@ '(UNLINKED<) CONSTANT % PROVIDES POINTER
% TO HEAD OF THIS VOCAB.
'3W- : W- W- W- ;
'BLIST : % LISTS THE NAMES OF ALL DEFINED BRANCHES
BRANCH-LIST W@
BEGIN
DUP W+ W@ DUP % GET LINK
IF
SWAP 3W- 3W-
W@ MSG CR
REPEAT
DROP DROP
IFCR
'PISTOL< MSG
;
% DO LOOP INDICES:
'I : 0 L@ ;
'J : 3 L@ ;
'K : 6 L@ ;
'I' : 2 L@ 1 L@ + 1- 0 L@ - ;
'J' : 5 L@ 4 L@ + 1- 3 L@ - ;
'K' : 8 L@ 7 L@ + 1- 6 L@ - ;
% SOME LOGICAL OPERATORS:
'LOR : IF DROP TRUE THEN ; % LOGICAL OR
'LAND : IF ELSE DROP FALSE THEN ; % LOGICAL AND
'LNOT : IF FALSE ELSE TRUE THEN ; % LOGICAL NEGATION
'MINUS : 0 SWAP - ;
'LTZ : MININT -1 .. ;
'GTZ : 1 MAXINT .. ;
'EQZ : LNOT ;
'ABS : DUP LTZ IF MINUS THEN ;
'EQ : - LNOT ;
'LE : MININT SWAP .. ;
'GE : MAXINT .. ;
'MIN : DDUP GE IF SWAP THEN DROP ;
'MAX : DDUP GE IF THEN SWAP DROP ;
% NUMBER OUTPUT ROUTINE:
% ASCII <-- DIGIT
'ASCII : DUP 9 GT IF 55
ELSE 48
THEN + ;
'<U#> : -1 SWAP
BEGIN RADIX W@ /MOD ABS SWAP DUP LNOT END
DROP ;
'#TYPE : BEGIN DUP -1 GT IF ASCII TYO REPEAT DROP ;
'= : DUP 0 LT IF 45 TYO MINUS THEN
<U#> #TYPE ;
'? : W@ = ;
% BELOW ARE WORDS THAT CONTROL DISPLAY OF CODE PRODUCED
% BY THE COMPILER; CAN BE USEFUL FOR DEBUGGING AND EDUCATION
'CODESHOW : IFCR "COMPILE BUFFER CONTAINS:" MSG CR
COMPBUF BEGIN DUP ? TAB W+
.C W@ OVER GT LNOT
END
DROP IFCR
;
'SHOWCODE : 0 COMPILE-END-PATCH W! ; 'CODESHOW FIND ARGPATCH
'NOSHOWCODE : COMPILE-END-PATCH OFF ;
'PROMPT : % DUPLICATES PRIMITIVE PROMPT
IFCR % FUNCTION
SP IF SP = THEN % EXCEPT STACK SIZE SHOWN
RADIX-INDICATOR C@ TYO
SYNTAXBASE MSG
"> " MSG
;
'PROMPT FIND PROMPT-PATCH W! % PATCHING IT
'ADDRESS : DUP FIND DUP
IF
UNDER
ELSE
IFCR 39 TYO DROP MSG
" NOT FOUND" MERR
THEN
;
'/ : /MOD DROP ;
'MOD : /MOD UNDER ;
% CHANGING NUMBER BASES:
'HEX : 72 RADIX-INDICATOR C! 16 RADIX W! ;
'DECIMAL : 88 RADIX-INDICATOR C! 10 RADIX W! ;
'OCTAL : 81 RADIX-INDICATOR C! 8 RADIX W! ;
'BINARY : 66 RADIX-INDICATOR C! 2 RADIX W! ;
%
'STACK : IFCR 40 TYO SP = 41 TYO % (STACKSIZE)
SP SP 12 MIN 1- 0 DO 2 SPACES DUP S@ = 1- LOOP
DROP ;
%
'RSTACK : IFCR 'R( MSG RP 1- = 41 TYO % RSTACK SIZE
RP 1- DUP 12 MIN 0 DO 2 SPACES DUP R@ = 1-
LOOP DROP ;
% RECURSE ALOWS ROUTINE OR COMPBUF TO CALL ITSELF
'RECURSE : 1 R@ W- % FIND IN WHICH WORD
0 R@ W- % FIND WHERE IS RECURSE USED
W! % PATCH
R> W- <R % BACKUP TO EXEC PATCH
;
%
'TELL : W- W- W@ MSG ;
'NEXT-LINK : 3W- W@ ;
%
% THIS BOMBS WHEN > NUMINSTRUCTIONS
'PNAME : DUP IF
LAST-PRIMITIVE
BEGIN DUP
IF DDUP W@ EQ
IF TELL TRUE
ELSE NEXT-LINK FALSE
THEN
ELSE '(NO_NAME) MSG LNOT
THEN
END
DROP
ELSE '; MSG DROP
THEN
;
%
'NAME : DUP PRIMITIVE? IF
PNAME
ELSE TELL
THEN ;
% VOCABULARY MAINTENANCE PACKAGE:
% LLIST ADDRESS AND NAME:
'LNAME : DUP = 3 SPACES NAME CR ;
% LIST LAST TEN WORDS:
'NEXT10 : IFCR 10 0 DO DUP LNOT IF ERR THEN
DUP LNAME NEXT-LINK LOOP
;
'TOP10 : % OF VOCBULARY TO WHICH DEFINITIONS
% ARE CURRENTLY BEING ADDED
CURRENT W@ W@ NEXT10 ;
'VLIST : % TOP TEN WORDS IN FIRST VOCABULARY TO BE SEARCHED
.V W@ W@ W@ NEXT10 ;
0 'ITEM VARIABLE
'FIND_PREVIOUS,NEXT : % GIVEN THREAD, FINDS ENTRY MOST
% RECENT AFTER ITEM AND THE ONE
% JUST BEFORE IT
% EXIT: PREV(LATER CHRON),NEXT
BEGIN
DUP NEXT-LINK DUP ITEM W@ GT
IF
UNDER
REPEAT
;
% IMPROVED FORGET DEVELOPED AUG 8, 1982
0 'FENCE VARIABLE
'VFORGET : % TOS IS A VOCABULARY TO BE CUT BACK
% TO BEFORE "ITEM"
DUP W@
DUP ITEM W@ GT
IF
FIND_PREVIOUS,NEXT UNDER W<-
ELSE
DROP DROP
THEN
;
'FORGET : ADDRESS DUP ITEM W! % SIMPLIFIES LOGIC!
FENCE W@ GT
IF
VBASE .V W! % RESET VSTACK
(PISTOL<) CURRENT W!
BRANCH-LIST W@
BEGIN
ITEM W@ OVER LT
IF
W+ W@
REPEAT
DUP BRANCH-LIST W!
BEGIN % TRIM EACH VOCAB
DUP VFORGET
W+ W@ DUP
IF
REPEAT
DROP
ITEM W@
DUP W- W- W@
DUP OLD-EOSTRINGS W!
CURRENT-EOSTRINGS W!
3W- DUP W@ CURRENT W@ W!
W- .D W!
ELSE
"BELOW FENCE" MERR
THEN
;
'FORGET FIND FENCE W! % SET FENCE
'VADDRESS : % TAKES NAME,VOCAB ON STACK; GETS ITS ADDRESS
% RETURNS IT ON TOP OF STACK IF IN VOCAB
OVER SWAP
VFIND
DUP IF UNDER
ELSE 39 TYO DROP MSG
" NOT IN VOCABULARY" MERR
THEN
;
'REMOVE : % TAKE NAME,VOCAB ON STACK ;GET ITS ADDRESS
% (SAVED IN ITEM); PUT PREVIOUS-> NEXT
DDUP VADDRESS DUP ITEM W!
DUP 2OVER W@ - % NOT LAST DEFINED?
IF NEXT-LINK PREVIOUS W@ 3W- % PREV->NEXT
ELSE NEXT-LINK OVER % VOCAB->NEXT
THEN W! DROP DROP
;
'ADD_LINK : % GIVEN VOCABULARY, LINK IN ITEM IN
% PROPER CHRONOLOGICAL ORDER
DUP W@ ITEM W@ LT
IF
DUP W@ ITEM W@ 3W- W! % UPDATE VOCAB
ITEM W@ W<- % INSTALL LINK TO
% OLD HEAD
ELSE
W@ FIND_PREVIOUS,NEXT
ITEM W@ 3W- W! % ADJUST LINK OF ITEM
3W- ITEM W@ W<- % LINK PREVIOUS
THEN
;
'UNLINK : % TAKES STRING ON TOS AND UNLINKS IT FROM
% SEARCH PATH AND LINKS IT INTO THE
% UNLINKED< VOCABULARY BRANCH
CURRENT W@ REMOVE
(UNLINKED<) ADD_LINK
;
'RELINK : % TAKES NAME ON TOS AND REMOVES IT FROM THE
% UNLINKED< VOCABULARY; LINKS IT INTO THE
% CURRENT VOCABULARY
(UNLINKED<) REMOVE
CURRENT W@ ADD_LINK
;
'DEFINITIONS : % SETS CURRENT TO TOP VOCABULARY IN IN VSTACK
.V W@ W@ CURRENT W!
;
'LAST-PRIMITIVE UNLINK
'W, UNLINK
'ALLOT UNLINK
'CODESHOW UNLINK
'VFORGET UNLINK
'REMOVE UNLINK
'ITEM UNLINK
'LNAME UNLINK
'FIND_PREVIOUS,NEXT UNLINK
'ADD_LINK UNLINK
'<V UNLINK
'PROMPT UNLINK
'TELL UNLINK
'PNAME UNLINK
% CASE INDICES:
'ICASE : 0 CASE@ ;
'JCASE : 2 CASE@ ;
'CASE-ADDR : 1 CASE@ ;
'(ENDCASE) : IFCR "ENDCASE ENCOUNTERED WITH VALUE = " MSG
ICASE = " AT " MSG CASE-ADDR = ERR ;
'(ENDCASE) ADDRESS
ENDCASE-PATCH W! % PATCH ENDCASE
% SPECIAL STRING ROUTINES:
% PACK puts TOS onto the end of the strings area.
'PACK : CURRENT-EOSTRINGS W@ C!
CURRENT-EOSTRINGS 1+W! ;
'=PACK : CURRENT-EOSTRINGS W@ <R
CURRENT-EOSTRINGS 1+W!
DUP LTZ IF 45 PACK MINUS THEN
<U#> BEGIN DUP 0 GE IF ASCII PACK REPEAT
DROP R> CURRENT-EOSTRINGS W@ OVER -
1- OVER C! ;
% =PACK IS USED TO CREATE A NUMBER STRING. IT
% TAKES THE TOP SIGNED NUMBER ON STACK AND CONVERTS IT
% TO A STRING THAT COULD BE OUTPUT BY MSG
% THE NEXT TWO ROUTINES TAKE AS INPUT
% A BUNCH OF STRING POINTERS
% AND THEIR NUMBER FROM THE TOP OF STACK.
'MSGS-COUNT : SP 1- OVER LT IF "NOT ENOUGH STRINGS"
MERR THEN
0 SWAP 1+ 1 DO I S@ C@ + LOOP ;
'MSGS : DUP <R DUP <R MSGS-COUNT LINE-SPACE?
R> 0 DO I' S@ MSG LOOP R> 0 DO DROP LOOP
;
'ENDCASE-PATCH UNLINK
'MSGS-COUNT UNLINK
'LINE-SPACE? UNLINK
% In the above, MSGS will output a bunch of strings
% that were left on stack IN THE ORDER they were placed
% on stack, trying to place them all on the same line;
% failing that, it will try and not split the individual
% strings across lines. It will be used to improve the:
% DISASSEMBLER PACKAGE
'DIS-TRIAL : % CONTAINS ALL REL-OPS IN THE KERNEL
DO +LOOP
DO LOOP
IF ELSE
THEN
OFCASE C: ;C ENDCASE
: ;
$: ;$
;
'NEXT-TRIAL : % CONVENIENCE TO STEP THROUGH DIS-TRIAL
W+ W+ DUP W@
;
'OP-TYPE : % USED TO DEFINE WORDS FOR TESTING KERNEL OPS
DUP :
3 EQ IF "" TRUE ELSE FALSE THEN
;
CURRENT W@ W@ 6 W* + W! % GET THE NAME OF DEFINITION
ARGPATCH % RECORD THE VALUE OF OPCODE
;
'3OVER FIND % IT STARTS WITH A LITERAL CONSTANT
W@ 'LITERAL CONSTANT
'Z : 'Z ;
'Z FIND % IT STARTS WITH A STRING LITERAL
W@ 'STRING-LIT CONSTANT
'TRANS FIND % IT IS A "$:" WORD
W- W@ '[$:] OP-TYPE
'DIS-TRIAL FIND
DUP W- W@ '[:] OP-TYPE
NEXT-TRIAL '(+LOOP) OP-TYPE
NEXT-TRIAL '(DO) OP-TYPE
NEXT-TRIAL '(LOOP) OP-TYPE
NEXT-TRIAL '(IF) OP-TYPE
NEXT-TRIAL '(ELSE) OP-TYPE
NEXT-TRIAL '(OFCASE) OP-TYPE
NEXT-TRIAL '(C:) OP-TYPE
W+ W+
NEXT-TRIAL '(:) OP-TYPE
NEXT-TRIAL '(;) OP-TYPE
W-
NEXT-TRIAL '($:) OP-TYPE
DROP
'REL-OP :
SWAP W+ W@ =PACK
" [" SWAP ']
4 MSGS W W+
;
'DIS-TOKEN :
DUP W@ OFCASE
(;) C: MSG DROP W ;C
LITERAL EQ C: W+ W@ =PACK MSG W W+ ;C
STRING-LIT EQ C: W+ W@ '" SWAP OVER
3 MSGS W W+ ;C
(DO) C: REL-OP ;C
(LOOP) C: REL-OP ;C
(+LOOP) C: REL-OP ;C
(IF) C: REL-OP ;C
(ELSE) C: REL-OP ;C
(OFCASE) C: REL-OP ;C
(C:) C: REL-OP ;C
(:) C: REL-OP ;C
($:) C: REL-OP ;C
TRUE C: NAME DROP W ;C
ENDCASE
;
'WORD-ID : IFCR 39 TYO DUP MSG SPACE ADDRESS ;
'DIS : WORD-ID
DUP W- DUP W@ DUP
[:] IF MSG DROP
ELSE [$:] IF MSG
ELSE "NON-STANDARD IMMEDIATE WORD"
MERR
THEN
THEN
NEXT-LINK % GET ^ TO END OF CODE
SWAP DO
TAB I DIS-TOKEN
+LOOP
TAB '; MSG
;
'Z UNLINK
'CASE-ADDR UNLINK
'(ENDCASE) UNLINK
'PACK UNLINK
'LITERAL UNLINK
'STRING-LIT UNLINK
'[:] UNLINK
'DIS-TRIAL UNLINK
'NEXT-TRIAL UNLINK
'OP-TYPE UNLINK
'[$:] UNLINK
'(+LOOP) UNLINK
'(DO) UNLINK
'(LOOP) UNLINK
'(IF) UNLINK
'(ELSE) UNLINK
'(OFCASE) UNLINK
'(C:) UNLINK
'(:) UNLINK
'($:) UNLINK
'REL-OP UNLINK
'DIS-TOKEN UNLINK
% TRACE PACKAGE:
% ROUTINE THAT DISPLAYS THE STATE OF THE MACHINE
% AT EACH TRACE AND TERMINATES TRACE AT END OF
% ROUTINE BEING TRACED.
'(TRACE) : STACK 48 INDENT 0 R@ W@ DUP
(;) IF MSG DROP 0 TRACE-LEVEL W!
ELSE NAME 2 SPACES
THEN
;
% PERFORM PATCH:
'(TRACE) ADDRESS TRACE-ADDR W!
'TRACE : WORD-ID "BEING TRACED:" MSG
RP 3 + TRACE-LEVEL W!
EXEC IFCR "TRACE COMPLETED" MSG
CR
;
'(;) UNLINK
'WORD-ID UNLINK
'(TRACE) UNLINK
% EDIT PACKAGE:
+27 TRANS 'OUTFILE-STATUS CONSTANT
+26 TRANS 'INPUTFILE-STATUS CONSTANT
STRINGSMAX 200 -
'SAFE-END CONSTANT
1 'OLDLINE# VARIABLE
EDITBUF 'OLDLINE^ VARIABLE
EDITBUF 'EOT VARIABLE
'NEWF : 1 OLDLINE# W!
EDITBUF OLDLINE^ W!
0 EDITBUF C!
EDITBUF EOT W!
;
NEWF % INITIALIZE EDITBUFFER
'NEXTLINE : DUP C@ DUP IF + 1+
ELSE "***NO SUCH LINE***" MERR
THEN ;
'LISTALL : 1 EDITBUF
BEGIN DUP C@
IF OVER = ": " MSG DUP MSG NEXTLINE
SWAP 1+ SWAP REPEAT DROP DROP ;
'ILLEGLIN : "***ILLEGAL LINE #***" MERR ;
'LFIND : DUP OLDLINE# LT IF DUP 1 MAXLINNO ..
LNOT IF ILLEGLIN THEN
EDITBUF OVER 1 DO
NEXTLINE LOOP
ELSE DUP OLDLINE# % CALCULATE # OF
- OLDLINE^ W@ % LINES NEEDED TO
SWAP 0 DO
NEXTLINE LOOP % ADVANCE
THEN
SWAP OLDLINE# W!
DUP OLDLINE^ W!
;
'LDIR : % CHARACTER BLOCK MOVE, INCREASING
% ON ENTRY: SOURCE, DESTINATION, #
% ON EXIT: SOURCE+#, DESTINATION+#
0 DO OVER C@ OVER C!
1+ SWAP 1+ SWAP
LOOP
;
'LDDR : % CHARACTER BLOCK MOVE, DECREASING
% ON ENTRY: SOURCE, DESTINATION, #
% ON EXIT: SOURCE-#, DESTINATION-#
0 DO
OVER C@ OVER C!
1- SWAP 1- SWAP
LOOP
;
'#GETLINE : % TAKES THE LINE NUMBERED BY THE
% TOP OF THE STACK AND TRANSFERS
% IT INTO LINEBUF
LFIND
LINEBUF 1+ NEXTCH^ W! % SYSTEM ^S
LINEBUF
OVER C@ IF % NOT NULL LINE?
OVER C@ 1+
LDIR
ELSE
1 OVER C! 1+ NEWLINE OVER C!
THEN
DROP DROP
% ECHO IF APPROPRIATE:
ECHO W@ IF LINEBUF MSG THEN
;
'#GETLINE FIND #GET-ADDR W! % DO THE PATCH
'MTUP : % ON ENTRY: ^ TO BAS OF BLOCK BOUNDED BY EOT
% ON EXIT: ^ TO BASE OF MOVED BLOCK AT STRINGSMAX
EOT W@ 1+ SWAP - % # BYTES
EOT W@ SWAP % SOURCE
STRINGSMAX SWAP % DESTINATION
LDDR
UNDER 1+
;
'OVERWRITE : % TAKES THE ^BOTTOM OF TEXT TO BE MOVED DOWN
% ^TEXT TO BE OVERWRITTEN
% AND ^LAST CHAR OF TEXT TO BE MOVED DOWN
% ON EXIT LEAVES NO ARGS BUT HAS ADJUSTED EOT
1+ 2OVER -
LDIR
1-
EOT W!
DROP
;
'MTDN : % ON ENTRY: ^ TO BASE OF BLOCK AT STRINGSMAX
% AND ^ TO BASE OF DESTINATION
STRINGSMAX
OVERWRITE
;
'LENTER : % TAKES ADDRESS ON TOP OF STACK AND MOVES INPUT
% INPUT LINE THERE; LEAVES A POINTER TO NEXT AVAILABLE
% LOCATION.
LINEBUF NEXTLINE LINEBUF
DO
I C@ OVER C! 1+
LOOP
;
'1POSARG? : % TESTS STACK TO SEE IF THERE IS EXACTLY
% ONE ARGUMENT; IT MUST BE POSITIVE.
% ON EXIT IT LEAVES THAT ARGUEMENT.
SP 1 EQ OVER -1 GT LAND
LNOT
IF "NOT SINGLE, POSITIVE ARGUEMENT" MERR
THEN
;
'ARG#ERR : "WRONG NUMBER OF ARGUMENTS" MERR ;
'LI : SP OFCASE
EQZ C: LISTALL ;C
1 EQ C: LFIND MSG ;C
2 EQ C: DDUP GT IF OVER + 1- THEN
1+ SWAP DO I = ": " MSG
I LFIND MSG LOOP ;C
TRUE C: ARG#ERR ;C
ENDCASE
;
'INPUT :
1POSARG?
DUP
LFIND
MTUP
SWAP DUP LFIND
BEGIN
SWAP DUP
= ": " MSG
1+ SWAP
GETLINE
LINEBUF C@ 1 GT
IF
LENTER
REPEAT
UNDER
MTDN
;
'(DELETE) : LFIND
DUP NEXTLINE
SWAP
EOT W@
OVERWRITE
;
'DELETE : 1POSARG?
(DELETE)
;
'REPLACE : 1POSARG?
DUP
(DELETE)
INPUT
;
'DELETES : SP 2 EQ
IF
DDUP LT IF OVER - 1+ THEN % IF ARG1<ARG2
% THEN INTERPRET
% AS RANGE !
0 DO DUP (DELETE) LOOP
DROP
ELSE
ARG#ERR
THEN
;
'1READ : % NO ERROR CHECKING
% TAKES A LINE FROM THE INPUT FILE AND
% APPENDS IT TO THE END OF THE
% TEXT IN THE EDIT BUFFER.
READLINE
0 EOT W@
LENTER
DUP
EOT W! % UPDATE EOT
C! % EMPLACE NEW EMPTY LINE
;
'READ : % TAKES A SINGLE ARGUMENT FROM STACK AS THE
% NUMBER OF LINES TO BE READ FROM THE INPUT
% FILE AND APPEND THEM TO THE END OF THE EDIT
% BUFFER.
1POSARG?
BEGIN
EOT W@ SAFE-END LT
OVER LAND
IF
1READ
1- % DECREASE COUNT
REPEAT
IF
"PREMATURE EOF ENCOUNTERED" MSG
THEN
;
'WRITE : % TAKES A SINGLE ARGUMENT FROM STACK AS
% THE NUMBER OF LINES TO BE TRANSFERRED
% FROM THE BEGINNING OF THE EDIT BUFFER
% TO THE OUTPUT FILE.
1POSARG?
1 LFIND % ADJUSTS POINTERS
BEGIN % IF NOT EOT, STILL MORE LINES TO SEND
DUP C@ 2OVER LAND
IF
DUP WRITELINE
NEXTLINE
SWAP 1- SWAP
REPEAT
% AT THIS POINT HAVE POINTER TO TEXT
% THAT IS NOT YET SENT AND NUMBER OF LINES
% YET TO BE SENT AFTER EOT
EDITBUF % DESTINATION
EOT W@
OVERWRITE
IF IFCR "PREMATURE EOT ENCOUNTERED" MSG THEN
;
'FINISH : % USED AT END OF EDIT SESSION TO TRANSFER
% CONTENTS OF EDIT BUFFER AND ANY ADDITIONAL
% REMAINING TEXT IN THE INPUT FILE TO THE
% OUTPUT FILE.
EDITBUF
BEGIN % EMPTY EDIT BUFFER
DUP C@
IF
DUP
WRITELINE
NEXTLINE
REPEAT
DROP
NEWF
BEGIN % TRANSFER REMAINDER OF INPUT FILE
INPUTFILE-STATUS
W@ -1 GT
IF
READLINE
LINEBUF WRITELINE
REPEAT
% SUMARIZE:
IFCR
"SUMARIZING: " MSG
INPUTFILE-STATUS W@ MINUS =
" LINES READ AND " MSG
OUTFILE-STATUS W@ MINUS =
" LINES WRITTEN." MSG
% CLOSING STATUS OF OUTPUT FILE:
+1 OUTFILE-STATUS W!
;
'MTDN UNLINK
'LENTER UNLINK
'1POSARG? UNLINK
'ARG#ERR UNLINK
'(DELETE) UNLINK
'1READ UNLINK
'OLDLINE^ UNLINK
'EOT UNLINK
'NEXTLINE UNLINK
'ILLEGLIN UNLINK
'LFIND UNLINK
'LDIR UNLINK
'LDDR UNLINK
'#GETLINE UNLINK
'MTUP UNLINK
'OVERWRITE UNLINK
% TEST INPUT:
1 INPUT
THIS IS THE FIRST LINE
THIS IS THE SECOND LINE
THIS IS THE THIRD LINE
THIS IS THE FOURTH LINE
THIS IS THE LAST LINE
% HELP PACKAGE (JUNE 15, 1982)
58 ':' CONSTANT
41 ')' CONSTANT
65 'A' CONSTANT
81 'Q' CONSTANT
'UC : % l.c. -> U.C.
DUP
97 122 ..
IF
32 -
ELSE
THEN
;
'COL#? : % RETURNS THE # OF ':' AT START OF LINE
0 LINEBUF 1+
BEGIN DUP C@ :' EQ IF
1+ SWAP 1+ SWAP
REPEAT
DROP
;
'TYIL : % READ FIRST CHAR FROM KEYBOARD; EXHAUST REST OF LINE
TYI DUP NEWLINE -
IF BEGIN TYI NEWLINE EQ END
THEN
;
'MENU : % ON ENTRY NOTHING
% ON EXIT: # OF LINES-1 (IF NO MENU, RETURN -1)
-1
BEGIN
GETLINE
COL#? LNOT IF
1+ DUP IF
DUP
1- A' + TYO
)' TYO
TAB
THEN
LINEBUF MSG
REPEAT
;
'TEXT : % PRINTS LINES UNTIL A LINE STARTING WITH A ":"
% NO STACK ACTIVITY
BEGIN
GETLINE
COL#? LNOT
IF
LINEBUF 1+ LINEBUF C@ TYPE
REPEAT
;
'LOCATE : % INPUT: SELECTION #, DELIM #
% OUTPUT: NONE
SWAP 1- 0
DO
BEGIN
GETLINE
COL#?
OVER
EQ
END
LOOP
DROP
;
'SELECTION : % INPUT: HIGHEST ACCEPTABLE
% OUTPUT: POSITIVE # OF SELECTION
0
BEGIN
DROP
"ENTER LETTER OF SELECTION(Q TO ABORT):" MSG
0 #LINES W! % RESET LINE COUNT
0 COLUMN W! % RESET COL COUNT
TYIL UC
DUP Q' EQ IF ABORT THEN
A' - 1+
DUP 1 3OVER ..
END
UNDER
;
'(HELP) :
LIST OFF
BEGIN
MENU
DUP GTZ % DOES MENU EXIST?
IF
SELECTION
COL#?
LOCATE
REPEAT
DROP
TEXT
;
'HELP : % WILL PROVIDE THE USER WITH AN ONLINE FACILITY TO
% LOOK UP THINGS
SP LNOT IF 'PISTOL.HLP THEN % SUPPLY DEFAULT NAME IF
% NONE IS PROVIDED
LOAD
(HELP)
CR "HELP COMPLETED" MSG
0 +7 TRANS W! % RETURN CONSOLE INPUT
;
':' UNLINK
')' UNLINK
'COL#? UNLINK
'MENU UNLINK
'TEXT UNLINK
'LOCATE UNLINK
'SELECTION UNLINK
'(HELP) UNLINK
;F
;
'SELECTION : % INPUT: HIGHEST ACCEPTABLE
% OUTPUT: POSITIVE # OF SELECTION
0